home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / source / gfxfx / cube.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  6KB  |  241 lines
  1.  
  2. program polygoned_cube;
  3. { THE very first polygoned cube }
  4. uses crt;
  5. const
  6.   vidseg:word=$a000;
  7.   dist=150;
  8.   point:array[0..7,0..2] of integer=(
  9.     (-35,-35,-35),(-35,-35,35),(35,-35,35),(35,-35,-35),
  10.     (-35, 35,-35),(-35, 35,35),(35, 35,35),(35, 35,-35));
  11.   planes:array[0..5,0..3] of byte=(
  12.     (0,4,5,1),(0,3,7,4),(0,1,2,3),(4,5,6,7),(7,6,2,3),(1,2,6,5));
  13.  
  14. type
  15.   tabtype=array[0..255] of integer;
  16.   planearray=array[0..5] of integer;
  17.  
  18. var
  19.   sintab:tabtype;
  20.   planez:planearray;
  21.   virscr:pointer;
  22.   virseg:word;
  23.  
  24. {----------------------------------------------------------------------------}
  25.  
  26. procedure setpal(c,r,g,b:byte); assembler;
  27. asm
  28.   mov dx,3c8h
  29.   mov al,[c]
  30.   out dx,al
  31.   inc dx
  32.   mov al,[r]
  33.   out dx,al
  34.   mov al,[g]
  35.   out dx,al
  36.   mov al,[b]
  37.   out dx,al
  38. end;
  39.  
  40. procedure cls(lvseg:word); assembler;
  41. asm
  42.   mov es,[lvseg]
  43.   xor di,di
  44.   xor ax,ax
  45.   mov cx,320*200/2
  46.   rep stosw
  47. end;
  48.  
  49. procedure flip(src,dst:word); assembler;
  50. asm
  51.   push ds
  52.   mov es,[dst]
  53.   mov ds,[src]
  54.   xor si,si
  55.   xor di,di
  56.   mov cx,320*200/2
  57.   rep movsw
  58.   pop ds
  59. end;
  60.  
  61. {----------------------------------------------------------------------------}
  62.  
  63. procedure Calcsinus(var SinTab : TabType); var I : byte; begin
  64.   for I := 0 to 255 do SinTab[I] := round(sin(2*I*pi/255)*128); end;
  65.  
  66. {----------------------------------------------------------------------------}
  67.  
  68. procedure quicksort(var a:planearray;lo,hi:integer);
  69.  
  70. procedure sort(l,r:integer);
  71. var i,j,x,y: integer;
  72. begin
  73.   i:=l; j:=r; x:=a[(l+r) div 2];
  74.   repeat
  75.     while a[i]<x do i:=i+1;
  76.     while x<a[j] do j:=j-1;
  77.     if i<=j then
  78.     begin
  79.       y:=a[i]; a[i]:=a[j]; a[j]:=y;
  80.       i:=i+1; j:=j-1;
  81.     end;
  82.   until i>j;
  83.   if l<j then sort(l,j);
  84.   if i<r then sort(i,r);
  85. end;
  86.  
  87. begin
  88.   sort(lo,hi);
  89. end;
  90.  
  91. {----------------------------------------------------------------------------}
  92.  
  93. procedure horline(xb,xe,y:integer; c:byte); assembler;
  94. asm
  95.   mov bx,[xb]
  96.   cmp bx,0
  97.   jz @out
  98.   mov cx,[xe]
  99.   jcxz @out
  100.   cmp bx,cx
  101.   jb @skip
  102.   xchg bx,cx
  103.  @skip:
  104.   dec bx
  105.   inc cx
  106.   sub cx,bx
  107.   mov es,virseg
  108.   mov ax,[y]
  109.   shl ax,6
  110.   mov di,ax
  111.   shl ax,2
  112.   add di,ax
  113.   add di,bx
  114.   mov al,[c]
  115.   shr cx,1
  116.   jnc @skip2
  117.   stosb
  118.  @skip2:
  119.   mov ah,al
  120.   rep stosw
  121.  @out:
  122. end;
  123.  
  124. procedure polygon(x1,y1,x2,y2,x3,y3,x4,y4:integer; c:byte);
  125. var
  126.   xpos:array[0..199,0..1] of integer;
  127.   mny,mxy,y:integer;
  128.   i:word;
  129.   s1,s2,s3,s4:shortint;
  130. begin
  131.   mny:=y1;
  132.   if y2<mny then mny:=y2;
  133.   if y3<mny then mny:=y3;
  134.   if y4<mny then mny:=y4;
  135.   mxy:=y1;
  136.   if y2>mxy then mxy:=y2;
  137.   if y3>mxy then mxy:=y3;
  138.   if y4>mxy then mxy:=y4;
  139.   s1:=byte(y1<y2)*2-1;
  140.   s2:=byte(y2<y3)*2-1;
  141.   s3:=byte(y3<y4)*2-1;
  142.   s4:=byte(y4<y1)*2-1;
  143.   y:=y1;
  144.   if y1<>y2 then repeat
  145.     xpos[y,byte(y1<y2)]:=integer(x2-x1)*(y-y1) div (y2-y1)+x1;
  146.     inc(y,s1);
  147.   until y=y2+s1 else xpos[y,byte(y1<y2)]:=x1;
  148.   y:=y2;
  149.   if y2<>y3 then repeat
  150.     xpos[y,byte(y2<y3)]:=integer(x3-x2)*(y-y2) div (y3-y2)+x2;
  151.     inc(y,s2);
  152.   until y=y3+s2 else xpos[y,byte(y2<y3)]:=x2;
  153.   y:=y3;
  154.   if y3<>y4 then repeat
  155.     xpos[y,byte(y3<y4)]:=integer(x4-x3)*(y-y3) div (y4-y3)+x3;
  156.     inc(y,s3);
  157.   until y=y4+s3 else xpos[y,byte(y3<y4)]:=x3;
  158.   y:=y4;
  159.   if y4<>y1 then repeat
  160.     xpos[y,byte(y4<y1)]:=integer(x1-x4)*(y-y4) div (y1-y4)+x4;
  161.     inc(y,s4);
  162.   until y=y1+s4 else xpos[y,byte(y1<y4)]:=x4;
  163.   for y:=mny to mxy do
  164.     horline(xpos[y,0],xpos[y,1],y,c);
  165. end;
  166.  
  167. {----------------------------------------------------------------------------}
  168.  
  169. function sinus(i:byte):integer; begin sinus:=sintab[i]; end;
  170. function cosinus(i:byte):integer; begin cosinus:=sintab[(i+192) mod 255]; end;
  171.  
  172. {----------------------------------------------------------------------------}
  173.  
  174. procedure Rotate;
  175. const xst=2; yst=0; zst=-2;
  176.  
  177. var
  178.   xp,yp,z:array[0..7] of integer;
  179.   x,y,i,j,k:integer;
  180.   n,Key,phix,phiy,phiz:byte;
  181.  
  182. begin
  183.   phix:=0; phiy:=0; phiz:=0;
  184.   fillchar(xp,sizeof(xp),0);
  185.   fillchar(yp,sizeof(yp),0);
  186.   repeat
  187.     while (port[$3da] and 8) <> 8 do;
  188.     while (port[$3da] and 8) = 8 do;
  189.     setpal(0,0,0,50);
  190.  
  191.     for n:=3 to 5 do
  192.       polygon(xp[planes[planez[n] and 7,0]],yp[planes[planez[n] and 7,0]],
  193.               xp[planes[planez[n] and 7,1]],yp[planes[planez[n] and 7,1]],
  194.               xp[planes[planez[n] and 7,2]],yp[planes[planez[n] and 7,2]],
  195.               xp[planes[planez[n] and 7,3]],yp[planes[planez[n] and 7,3]],0);
  196.  
  197.     for n:=0 to 7 do begin
  198.       i:=(cosinus(phiy)*point[n,0]-sinus(phiy)*point[n,2]) div 128;
  199.       j:=(cosinus(phiz)*point[n,1]-sinus(phiz)*i) div 128;
  200.       k:=(cosinus(phiy)*point[n,2]+sinus(phiy)*point[n,0]) div 128;
  201.       x:=(cosinus(phiz)*i+sinus(phiz)*point[n,1]) div 128;
  202.       y:=(cosinus(phix)*j+sinus(phix)*k) div 128;
  203.       z[n]:=(cosinus(phix)*k-sinus(phix)*j) div 128;
  204.       xp[n]:=160+(-x*dist) div (z[n]-dist);
  205.       yp[n]:=100+(-y*dist) div (z[n]-dist);
  206.     end;
  207.  
  208.     for n:=0 to 5 do
  209.       planez[n]:=(integer(z[planes[n,0]]+z[planes[n,1]]+
  210.                           z[planes[n,2]]+z[planes[n,3]]) div 4)
  211.                           shl 3+n;
  212.  
  213.     quicksort(planez,0,5);
  214.  
  215.     for n:=3 to 5 do
  216.       polygon(xp[planes[planez[n] and 7,0]],yp[planes[planez[n] and 7,0]],
  217.               xp[planes[planez[n] and 7,1]],yp[planes[planez[n] and 7,1]],
  218.               xp[planes[planez[n] and 7,2]],yp[planes[planez[n] and 7,2]],
  219.               xp[planes[planez[n] and 7,3]],yp[planes[planez[n] and 7,3]],(planez[n] and 7)+1);
  220.  
  221.     inc(phix,xst); inc(phiy,yst); inc(phiz,zst);
  222.     setpal(0,0,0,0);
  223.     flip(virseg,vidseg);
  224.   until keypressed;
  225. end;
  226.  
  227. {----------------------------------------------------------------------------}
  228.  
  229. var i:byte;
  230. begin
  231.   Calcsinus(SinTab);
  232.   asm mov ax,13h; int 10h; end;
  233.   getmem(virscr,64000);
  234.   virseg:=seg(virscr^);
  235.   cls(virseg);
  236.   for i:=0 to 5 do setpal(i+1,10+i*2,30+i*2,10+i*2);
  237.   Rotate;
  238.   freemem(virscr,64000);
  239.   textmode(lastmode);
  240. end.
  241.